Shareware Grab Bag/Shareware Grab Bag.iso/007/qbsub10.arc/OMNI.SUB

Text File | 1986-06-25 | 13.6 KB | 427 lines

' OMNI.SUB -- MSDOS QuickBASIC universal subroutines        25 June 86
'        by David L. Poskie     [phone]
'                  7118 Raymond Rd. Madison, WI 53719
' Please run any suggestions, corrections, additions, or changes by me.
' I can be messaged on all the major Madison, WI RBBS's.

'| OMNI.SUB contains subroutines I use in virtually every other SUB file and
'|  in my general programming.  All of these could reside in one or more of the
'|  specialized SUB files, but then I'd forever have to be $INCLUDE'ing those
'|  SUB files, and would be forced to compile too many subroutines I didn't
'|  need. The bottom line is, if you use the subroutines in the SUB files
'|  contained in QBSUB.ARC, ALWAYS include this one, too.
'|  >>> The main program must contain the following definitions:
'|            False = 0
'|            True = NOT False

    '| Get Key Input Subroutines -- an interactive series:
    '|    GetKeyInput -- Gets a bomb-proof file name input
    '|    GetUpperCase  -- Converts alpha ASCII characters to upper case
    '|    GetKeyClear -- Clears keyboard buffer & gets user response
    '|      GetKeyCode --  Returns extended & ASCII code of an INKEY$
    '|    GetKeyLoop  -- Gets a key from keyboard buffer
    '|    GetKeyPress -- Prompts user for keypress to continue
    '| Other Subroutines:
    '|      Delay -- a hardware independent delay timer
    '|    Center -- Center text via TAB and go to next line
    '|    CenterStay -- Center text via TAB and stay there
    '|    CenterStay -- Center text via LOCATE and stay there
    '|    ClearIn -- Reverse clear screen from edges into center
    '|    ClearOut -- Reverse clear screen from center to edges
    '|    Sign -- Frame text set by LOCATE
    '|    SignCenter -- Frame centered text on a line
    '|    Glow -- Print words with first letter of each word highlighted
    '|    ReadScreen -- get color attributes of a location on screen

   'GetKeyInput
   ' This subroutine attempts to get a bomb-proof, echoing input. I wanted
   '  it particularly to get FILENAME.EXT, but it is a good way generally to
   '  keep input within bounds in windows. If desired, it accepts control
   '  character input directly and uses the alias, `\' to input a <CR>, meant
   '  as part of the Text$ input. It locates the cursor, prints a shaded
   '  line of length, KeyMax, and then gets the input.
   ' Input:
   '       X = row
   '       FG = text color of the hatched area
   '       BG = background color of hatched area
   '       MG = background color of all that's actually input
   '       KeyMax = maximum allowable input length
   '       Text$ = input prompt string (destroyed in subroutine)
   ' Output:
   '       Text$ = line input by user
   ' Other Vars: IsExtended -- extended code flag
   '         KeyCode -- ASCII code for input character
   '         RelX , RelY -- relative X,Y for input line
   '             HoldFG , HoldBG -- restore colors
GetKeyInput:
    ' Locate & print the input prompt in Text$
    IF Text$ <> ""                            _
       THEN Y = 40 - (LEN(Text$) + KeyMax) /2
    LOCATE X , Y , 0
    PRINT Text$;
    ' Now throw Text$ away so we can use the variable
    Text$ = ""
    ' If KeyMax not set, make it a maximum input line
    IF KeyMax = 0                            _
       THEN KeyMax = 255
    ' Make a relative X , Y of the current cursor position
    RelX = CSRLIN
    RelY = POS(0)
    GOSUB ReadScreen
    GOSUB Hatch
InKey:
    ' Get character
    GOSUB GetKeyCode
    ' A <CR> is the only way to get out of here
    IF KeyCode = 13                            _
       THEN COLOR HoldFG , HoldBG :                    _
        LOCATE , , 1 :                        _
        RETURN
    ' If not <BS>, continue processing
    IF NOT(KeyCode = 8)                        _
       THEN GOTO DoInKey
    ' If we can't backspace, then go
    IF Text$ = ""                            _
       THEN SOUND 99,1 :                        _
        GOTO InKey
    ' Else do a destructive backspace
    COLOR , BG
    PRINT CHR$(176); CHR$(29); CHR$(29);
    COLOR FG + 16 , MG
    PRINT CHR$(95); CHR$(29);
    COLOR FG
    Text$ = LEFT$(Text$ , LEN(Text$) - 1)
GOTO InKey
DoInKey:
    ' Check length
    IF LEN(Text$) = KeyMax                        _
       THEN SOUND 99,1 :                        _
        GOTO InKey

    ' Not extend key
    IF IsExtended = False                        _
       AND KeyCode > 31                        _
           THEN GOTO DoStandardKey
    ' If IsExtended = False, then warn & get another key
    IF IsExtended = False                        _
       THEN SOUND 99 , 1 :                        _
        GOTO InKey
    ' Not ASCII 0
    IF NOT(IsExtended = False AND KeyCode = 3)            _
       THEN SOUND 99,1 :                        _
        GOTO InKey
    IF IsExtended = True                        _
       THEN KeyCode = 0 :                         _
        GOTO DoControlKey

    SOUND 99 , 1
GOTO InKey
DoStandardKey:
    ' Standard text character
    IF KeyCode > 31                            _
       THEN IsStd = True :                        _
        PRINT CHR$(KeyCode); :                    _
        COLOR  , HoldBG :                    _
        Num = 32                        _
       ELSE IsStd = False
    IF IsStd                            _
       AND POS(0) < RelY + KeyMax                     _
           THEN COLOR FG + 16 , MG :                _
            Num = 95
    IF IsStd                            _
       THEN PRINT CHR$(Num); :                    _
        COLOR FG , MG :                        _
        PRINT CHR$(29);
GOTO DoCRKey
DoControlKey:
    ' Control character
    COLOR 15
    PRINT CHR$(KeyCode + 64);
    COLOR 7
DoCRKey:
    ' \ = <CR>
    IF KeyCode = 92 THEN Text$ = Text$ + CHR$(13) :            _
       GOTO InKey
    ' Add & get more
    Text$ = Text$ + CHR$(KeyCode)
GOTO InKey

' GetKeyxxxx
' A fall-through series of input utility subroutines
' Prompt the user to press a key (handy for user-released pauses)
GetKeyPress:
    LOCATE 25 , 71
    PRINT "KEYPRESS";
    GOTO GetKeyLoop
' Clear the keyboard buffer (sometimes you want no accidental response)
GetKeyClear:
    WHILE INKEY$ <> ""
    WEND                ' Falls through to GetKeyLoop


' Get the key input (coming directly here allows reading keyboard buffer).
GetKeyLoop:
    '|    Temp$ = one ASCII character, capitalized, if alpha.
    Temp$ = INKEY$
    IF Temp$ = ""                            _
       THEN GOTO GetKeyLoop

' You can come in here with a full Temp$
GetUpperCase:
    Num = 1
    WHILE Num <= LEN(Temp$)
          KeyCode = ASC(MID$(Temp$ , Num , 1))
          KeyCode = KeyCode + 32 * (KeyCode > 96 AND KeyCode < 123)
          MID$(Temp$ , Num , 1) = CHR$(KeyCode)
          Num = Num + 1
    WEND
RETURN


    '| Get a character from the keyboard, then determine the
    '|  ASCII key code (KeyCode) & set the extended code flag (IsExtended).
    '|  Input: Temp$ = one character from an INKEYS query
    '|  Returns:
    '|    KeyCode = ASCII key code
    '|    IsExtended = True if extended code else IsExtended = False
GetKeyCode:
    Temp$ = INKEY$
    IF Temp$ = ""                            _
       THEN GOTO GetKeyCode

    ' If you already have an INKEY$ in Temp$, you can start right here
GetCode:
    IF LEFT$(Temp$ , 1) = CHR$(0)                    _
       THEN Temp$ = MID$(Temp$ , 2) :                _
        IsExtended = 1                         _
        ELSE IsExtended = 0
    KeyCode = ASC(Temp$)
    LOCATE , , 0
RETURN


    ' Hardware INdependent timer routine requires Dly = time in seconds
    '  to delay -- this can be a decimal fraction for very short delays.
    '  The shortest possible effective setting is Dly = .05 seconds.
    ' NOTE: If you are using DEFINT and it includes variables starting
    '        with `D', you must declare DEFSNG D, else these won't work
    '        with times less than a second.
    '       The simpler, SOUND 32767 , Dly doesn't work on my Leading
    '        Edge (Early XT clone). Dunno why.

    ' Need to isolate Dly, so it can then continue to be used
    '  when you want to return here for the same delay time.
    ' >>> Watch using D in main program -- gets to be a big number here.
Delay:
    D = 0
    D = Dly + TIMER
        WHILE D > TIMER
    WEND
    D = 0
RETURN


'| Screen centering:
'| Enter with Text$ containing the string to be centered
'| Three 80-column width subroutines:
'|        Center uses TAB and does a <CR> -- best when you aren't
'|                     in control of CSRLIN and not changing colors.
'|
'|        CenterStay uses TAB and stays on that line -- best for
'|               input requests and not changing colors.
'|
'|        CenterPoint uses LOCATE & CSRLIN, staying on the line --
'|               most useful for changing colors in the line, but
'|               requires careful control via CSRLIN.

'    ________________________ CENTERING SUBROUTINES _______________________

    ' Center Text$ via TAB and go to next line
Center:
    PRINT TAB(40 - (LEN(Text$) / 2)) Text$
RETURN


    ' Center Text$ via TAB and remain at its end
CenterStay:
    PRINT TAB(40 - (LEN(Text$) / 2)) Text$;
RETURN


    ' Center Text$ via LOCATE command and remain at its end
CenterPoint:
    LOCATE CSRLIN + 1 , 40 - (LEN(Text$) / 2)
    PRINT Text$;
RETURN


'  _____________________ SCREEN CLEARING SUBROUTINES ____________________

'| Reverse screen clearing:
'| SCREEN.SUB contains subroutines only for reverse screen clearing because
'|  forward screen clearing is an easy programming task.
'|
'| Enter with Num = the number of lines to clear from the current line upward.
'| Also, there is provision to use a time delay to control the speed of screen
'|  erasure. You must set Dly = 0 if you want no delay in screen clearing.
'|  >> This Dly is not factored for seconds -- it is a raw number for a
'|  timing loop; thus it can be set for faster loops than the usual Dly would
'|  produce -- experiment with this ( I usually set Dly = 0). By the way,
'|  the subroutines actually print spaces to clear the required points.
'| If you fail to set Dly, the routine will accept a previously set variable.
'|  This is highly likely if you are using the Delay subroutine, which is
'|  contained in this file. Best to habitually use Dly = 0 before entering.
'| Two reverse clear subroutines:
'|        ClearIn clears from the current line up, working from
'|            the edges of the screen into the center.
'|        ClearOut clears from the current line, working from
'|             the center of the screen to the edges.

    'Clear the screen from current position back for Num lines,
    ' working from the center out.
ClearOut:
    RelX = CSRLIN
    RelY = 40
    FOR X = 0 TO Num
        FOR Y = 0 TO 39
        LOCATE RelX - X , RelY + Y + 1 , 0
        PRINT " ";
        LOCATE RelX - X , RelY - Y
        PRINT " ";
        FOR Temp = 0 TO Dly : NEXT Temp
        NEXT Y
    NEXT X
RETURN


    'Clear the screen from current position back for Num lines,
    ' working from the edges in.
ClearIn:
    RelX = CSRLIN
    RelY = 40
    FOR X = 0 TO Num
        FOR Y = 39 TO 0 STEP -1
        LOCATE RelX - X , RelY + Y + 1 , 0
        PRINT " ";
        LOCATE RelX - X , RelY - Y
        PRINT " ";
        FOR Temp = 0 TO Dly : NEXT Temp
        NEXT Y
    NEXT X
RETURN


    ' Prints a hatched background to guide input
    ' Input: FG , RelX , RelY , KeyMax = allowed length of input
Hatch:
    PRINT STRING$(KeyMax , 176);
    LOCATE RelX , RelY
    COLOR FG + 16 , MG
    PRINT CHR$(95); CHR$(29);
    COLOR FG
RETURN


'    _____________________ Sign PRINTING SUBROUTINES ____________________

    ' Show Text$ at a point previously set by the LOCATE n , n comand.
    ' That corner will be the upper left corner of a sign looking like:
    '
    '        *******************************
        '               ** This is the text in Text$ **
    '            *******************************
    '
    ' The border will be the ASCII character input as KeyCode.
    ' You can specify the colors FG, BG, & MG -- these variables are
    ' typically used by other subroutines to set foreground color, back-
    ' ground color, and margin color respectively. In this subroutine, the
    ' screen margin will not be altered, and MG will be the color to use
    ' for the ASCII character margin built around Text$. X,Y is top left.
Sign:
    'Read color attributes for restoration after printing strings
    RelX = X
    RelY = Y
    GOSUB ReadScreen
    LOCATE X , Y , 0
    COLOR MG , BG
    PRINT STRING$(LEN(Text$) + 6 , KeyCode);
    LOCATE X + 1 , Y
    PRINT CHR$(KeyCode); CHR$(KeyCode); " ";
    COLOR FG , BG
    PRINT Text$;
    COLOR MG , BG
    PRINT " "; CHR$(KeyCode); CHR$(KeyCode);
    LOCATE X + 2 , Y
    PRINT STRING$(LEN(Text$) + 6 , KeyCode);
    COLOR HoldFG , HoldBG
    LOCATE , , 1
RETURN


    ' Show Text$ centered on current line, looking like:
    '
    '        ***************************
        '                This is the text in Text$
    '            ***************************
    '
    ' The border is the ASCII character input as the variable, KeyCode.
    ' Color use is identical to Sign, but notice this subroutine does
    '  not frame Text$ horizontally.
SignCenter:
    'Read color attributes for restoration after printing strings
    IF NOT Y THEN Y = 1
    RelX = X
    RelY = Y
    GOSUB ReadScreen
    ' Print the top frame
    LOCATE X , 39 - (LEN(Text$) / 2) , 0
    COLOR MG , BG
     PRINT STRING$(LEN(Text$) + 2 , KeyCode);
    ' Print Text$
    COLOR FG , BG
    LOCATE X + 1 ,  39 - (LEN(Text$) / 2)
    PRINT " ";Text$;" ";
    ' Print the bottom frame
    LOCATE X + 2 ,  39 - (LEN(Text$) / 2)
    COLOR MG , BG
     PRINT STRING$(LEN(Text$) + 2 , KeyCode);
    COLOR HoldFG , HoldBG
    LOCATE , , 1
RETURN


    ' Subroutine to highlight the first character of each word
    '  in a string of words contained in Text$.
    ' Primarily used to provide a first-letter prompt string.
    ' Input:
    '    The colors Glow, FG, BG, MG
    '    The string of words Text$
    '    The X & Y location to print Text$
    'This subroutine adds a leading space to Text$, so you may
    ' need to adjust the Y variable accordingly.
Glow:
    LOCATE X , Y
    COLOR Glow
    PRINT " ";LEFT$(Text$ , 1);
    COLOR FG
    FOR Num = 2 TO LEN(Text$)
        Temp$ = MID$(Text$ , Num , 1)
        PRINT Temp$;
        IF ASC(Temp$) = 32                        _
           THEN COLOR Glow                        _
           ELSE COLOR FG
    NEXT Num
RETURN


    'Read color attributes for restoration after printing strings
    'Input: RelX, RelY = target row & column
    'Output: HoldFG = current foreground, HoldBG = current background
ReadScreen:
    ' Read foreground color
    HoldFG = ((SCREEN (RelX , RelY , 1)) MOD 16)
    ' Read background color
    HoldBG = (((SCREEN (RelX , RelY , 1)) - HoldFG) / 16) MOD 128
RETURN
' >>>>> Physical EOF OMNI.SUB  25 June 86